home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / ODE / elmnts < prev    next >
Encoding:
Text File  |  1992-01-14  |  12.7 KB  |  580 lines
  1. \ ELEMENTS CLASS
  2. \ OB.ELMNTS provides an ordered set of N dimensional elements.
  3. \
  4. \ Author: Phil Burk
  5. \ Copyright 1986 Delta Research
  6. \
  7. \ MOD: PLB 7/30/86 Added FILL.DIM:
  8. \ NOD: PLB 11/8/86 Put TAB in PRINT.ELEMENT: OB.OBJLIST
  9. \ MOD: PLB 11/21/86 Optimized MOVE:
  10. \ MOD: PLB 12/26/86 Added DUMP.SOURCE: and DUMP.ELEMENT:
  11. \ MOD: PLB 1/14/87 Removed dead code, don't zero data in CLEAR:
  12. \ MOD: PLB 2/10/87 FIRST: leaves pointer at second element.
  13. \ MOD: PLB 2/13/87 LAST: leaves pointer past last, added
  14. \      FOREWARD: , BACKWARD: .
  15. \ MOD: PLB 2/19/87 Added EMPTY: method.
  16. \ MOD: PLB 5/13/87 Optimized GET: and PUT:
  17. \ MOD: PLB 9/3/87 Added DO: for iteration.
  18. \ MOD: PLB 9/19/87 Added COPY: , SPLIT: , and SMEAR: .
  19. \ MOD: PLB 11/3/87 Add DELETE:
  20. \ MOD: PLB 9/13/88 Remove MRESET
  21. \ MOD: PLB 1/6/88  Moved increment of IV-MANY in INSERT:
  22. \      to fix overwriting bug.
  23. \ MOD: PLB 3/8/89 Made DO: work on other Forths, fix FILL.DIM: msg,
  24. \ MOD: PLB 5/17/89 Added GOTO: and WHERE:
  25. \ MOD: PLB 12/15/89 Added STUFF{ and }NEWSTUFF:
  26. \ MOD: PLB 10/30/90 Better protection in CHOP: and SPLIT:
  27. \ MOD: PLB 12/1/90 Make NEXTWRAP: loop without error.
  28. \ 00001 PLB 1/14/92 Use ?NEW: in ?INSTANTIATE:
  29.  
  30. ANEW TASK-ELMNTS
  31.  
  32. \ Declare OB.ELMNTS methods.
  33. METHOD RESET:   ( First method )
  34. METHOD MANY:
  35. METHOD ED2I:                METHOD I2ED:
  36. METHOD ED.AT:               METHOD ED.TO:
  37. METHOD DIMENSION:           METHOD ADD:
  38. METHOD FIRST:               METHOD LAST:
  39. METHOD NEXT:                METHOD CURRENT:
  40. METHOD CHECK.UNDER:         METHOD CHECK.OVER:
  41. METHOD STRETCH:             METHOD CHOP:
  42. METHOD REMOVE:              METHOD INSERT:
  43. METHOD PRINT.ELEMENT:       METHOD PRINT.DIMENSION:
  44. METHOD SET.MANY:            METHOD EXECUTE:
  45. METHOD MAX.ELEMENTS:        METHOD MOVE:
  46. METHOD MANYLEFT:            METHOD I2ADDR:
  47. METHOD DUMP.SOURCE:         METHOD DUMP.ELEMENT:
  48. METHOD BACKWARD:            METHOD FOREWARD:
  49. METHOD FILL.DIM:            METHOD DO:
  50. METHOD SPLIT:               METHOD SMEAR:
  51. METHOD COPY:
  52. METHOD GOTO:                METHOD WHERE:
  53. METHOD NEXTWRAP:
  54.  
  55. \ Variables to avoid stack dancing in elmnts methods
  56. U: ZZEL1
  57. U: ZZEL2
  58. U: ZZEL3
  59. U: ZZEL4
  60. U: ZZEL5
  61.  
  62. ( OB.ELMNTS CLASS )
  63. ( This object has an array of "elements" where an element is )
  64. ( a set of values.  It is equivalent to a 2 dimensional list. )
  65. ( Each row can be considered an element. )
  66. ( This can also be considered as a set of multidimensional points)
  67. :CLASS OB.ELMNTS   <SUPER OB.ARRAY
  68.     IV.LONG IV-DIMENSION   ( number of columns )
  69.     IV.LONG IV-#ELEMENTS ( maximum number of data elements )
  70.     IV.LONG IV-MANY     ( Count of elements with data in them )
  71.     IV.LONG IV-CURRENT  ( Current element pointer )
  72.  
  73. :M RESET:     ( -- , Reset pointers )
  74.     0 iv=> iv-current
  75. ;M
  76.  
  77. :M EMPTY:  ( -- , set to no valid data condition )
  78.     reset: self
  79.     0 iv=> iv-many
  80. ;M
  81.  
  82. :M CLEAR:  (  -- , clear data and reset pointers  )
  83.     clear: super
  84.     empty: self
  85. ;M
  86.  
  87. :M INIT:  (  --  )
  88.     init: super
  89.     reset: self
  90.     0 iv=> iv-dimension
  91.     0 iv=> iv-#elements
  92.     0 iv=> iv-many
  93. ;M
  94.  
  95. :M FREE: ( -- , clear some ivars )
  96.     free: super
  97.     0 iv=> iv-#elements
  98.     0 iv=> iv-dimension
  99. ;M
  100.  
  101. :M ?NEW:  ( maxindex #dimensions -- addr | 0, allocate data space )
  102.     2dup *  ?new: super >r
  103.     iv=> iv-dimension
  104.     iv=> iv-#elements   ( for keeping track of max data elements )
  105.     r>
  106. ;M
  107.  
  108. :M NEW: ( #cells -- , abort if error )
  109.     ?new: self <new:error>
  110. ;M
  111.  
  112. :M ED2I: ( element# dimension# -- index , calculate  index)
  113.     swap iv-dimension  *  +
  114. ;M
  115.  
  116. :M I2ED: ( index -- element# dimension# )
  117.     iv-dimension  /mod swap
  118. ;M
  119.  
  120. \ This is not really fast but is still useful.
  121. :M I2ADDR: ( index -- address , calculate address of item )
  122.     iv-width * iv-pntr +
  123. ;M
  124.  
  125. :M ED.AT:  ( e# d# -- value , fetch value from shape )
  126.     ed2i: self  at.self
  127. ;M
  128.  
  129. :M ED.TO:  ( value e# d# -- , store value in shape )
  130.     ed2i: self  to.self
  131. ;M
  132.  
  133. :M DIMENSION:    ( -- #dimensions , return # of dimensions )
  134.     iv-dimension
  135. ;M
  136.  
  137. :M MAX.ELEMENTS:   ( -- max , max number of elements allowed )
  138.     iv-#elements
  139. ;M
  140.  
  141. \ PUT: and GET: have been optimized at the expense of elegance.
  142. \ This stores into an entire element (or row).
  143. \ The number of data items must match the number of dimensions.
  144. :M PUT:   ( V1 V2 V3 ... VN E# -- , Put values in e#)
  145.     1+ iv-dimension ?dup
  146.     IF  dup>r *  ( Calculate index of last value + 1 )
  147.         r> 0
  148.         DO   ( For all values )
  149.             1- tuck to.self
  150.         LOOP drop
  151.     ELSE
  152.         " PUT: OB.ELMNTS"  " No memory allocated!"
  153.         er_fatal ob.report.error
  154.     THEN
  155. ;M
  156.  
  157. :M GET:   ( E# -- V1 V2 V3 ... VN   , Get values from e#)
  158.     iv-dimension dup>r *  ( Calculate index of first value )
  159.     dup r> + swap
  160.     DO   ( For all values )
  161.         i at.self
  162.     LOOP
  163. ;M
  164.  
  165. :M ADD:  (  v1 v2 ... vn -- , add element to end )
  166.     iv-many   put: self
  167.     1 iv+> iv-many
  168. ;M
  169.  
  170. :M FIRST:  (  -- v1 v2 ... vn , return 1st element & setpntr=1)
  171.     0 get: self
  172.     1 iv=> iv-current
  173. ;M
  174.  
  175. :M LAST:  ( -- v1 ... vn , return last element & set pointer )
  176.     iv-many  dup iv=> iv-current
  177.     1- get: self
  178. ;M
  179.  
  180. :M MANY: ( -- N , Number of elements with valid data )
  181.     iv-many
  182. ;M
  183.  
  184. :M SIZE:  (  -- size , return number of single values  )
  185.     iv-many   dimension: self *
  186. ;M
  187.  
  188. :M MANYLEFT:  ( -- N , # elements remaining after current )
  189.     iv-many iv-current  -
  190. ;M
  191.  
  192. :M CURRENT:  ( -- VAL , Fetch current value )
  193.     iv-current
  194.     dup 1+ iv-many  >
  195.     IF
  196.         " CURRENT: OB.ELMNTS"  " Past end of list!"
  197.         er_fatal ob.report.error
  198.     THEN    get: self
  199. ;M
  200.  
  201. :M NEXT:  ( -- v1 v2 ... vn , return next element and inc pntr)
  202.     iv-current get: self
  203.     1 iv+> iv-current
  204. ;M
  205.  
  206. :M NEXTWRAP:  ( -- v1 v2 ... vn , wrap if at end )
  207.     iv-current get: self
  208.     iv-current 1+ dup iv-many >=
  209.     IF drop 0
  210.     THEN iv=> iv-current
  211. ;M
  212.  
  213. :M CHECK.UNDER: ( #sub -- underflow? , true if trying to remove too many)
  214.     iv-many >
  215. ;M
  216.  
  217. :M CHECK.OVER: ( #add -- overflow? , true if danger of overflow )
  218.     iv-many +  max.elements: self >
  219. ;M
  220.  
  221. :M MOVE: ( from to count -- , move elements up or down )
  222.     ?dup
  223.     IF  iv-width *  iv-dimension * >r ( number of bytes )
  224.         0 ed2i: self i2addr: self swap
  225.         0 ed2i: self i2addr: self swap
  226.         r> move
  227.     ELSE 2drop
  228.     THEN
  229. ;M
  230.  
  231.  
  232. :M SPLIT: ( start count -- , push data up )
  233.     zzel5 ! zzel4 !       ( avoid stack dancing )
  234.     zzel5 @ check.over: self
  235.     IF  " SPLIT: OB.ELMNTS" " Too many elements"
  236.         er_return ob.report.error
  237.     ELSE
  238.         zzel4 @ iv-many <
  239.         IF    zzel4 @ iv-current  <
  240.             IF    zzel5 @ iv+> iv-current
  241.             THEN
  242.             zzel5 @ iv+> iv-many
  243. \
  244. \ Push others up.
  245.             zzel4 @ ( -- from )
  246.             dup zzel5 @ + ( -- from to )
  247.             iv-many 1 pick - ( -- from to count )
  248.             move: self
  249.         ELSE
  250.             " SPLIT: OB.ELMNTS" " Past last element."
  251.             er_return ob.report.error
  252.         THEN
  253.     THEN
  254. ;M
  255.  
  256. :M SMEAR: ( start count -- , copy one element up over others )
  257.     over + 1+ over 1+
  258.     DO dup get: self
  259.         i put: self
  260.     LOOP drop
  261. ;M
  262.  
  263. :M STRETCH: ( start count -- , copy element at start up, pushing others)
  264.     over 1+ iv-many <
  265.     IF
  266.         over 1+ over split: self
  267.     ELSE dup iv+> iv-many
  268.     THEN
  269.     smear: self
  270. ;M
  271.  
  272. :M INSERT:  ( v1 v2 ...vn index  -- ,insert and expand )
  273.     1 check.over: self
  274.     IF  " INSERT: OB.ELMNTS" " Too many elements"
  275.         er_return ob.report.error
  276.         put: self bell
  277.     ELSE
  278.         dup iv-current  <  ( -- v1-n index flag )
  279.         IF 1 iv+> iv-current THEN  ( Adjust pointer )
  280.         dup iv-many <  ( move if any higher data )
  281.         IF ( -- v1-n index )
  282.             dup dup 1+ over iv-many swap - ( v1-n index from to count)
  283.             move: self
  284.         THEN ( v1-n index )
  285.         1 iv+> iv-many
  286.         put: self   ( put in new element )
  287.     THEN
  288. ;M
  289.  
  290. :M CHOP: ( start count -- , remove a chunk )
  291.     2dup zzel5 ! zzel4 !       ( avoid stack dancing )
  292.     + check.under: self
  293.     IF
  294.         cr ZZEL4 @ .  ZZEL5 @ .
  295.         " CHOP: OB.ELMNTS" " Not enough elements"
  296.         er_return ob.report.error
  297.     ELSE
  298.         zzel4 @ iv-current  <
  299.         IF    iv-current  zzel5 @ -
  300.             zzel4 @ max iv=> iv-current
  301.         THEN
  302.         zzel5 @ negate iv+> iv-many
  303.  
  304. \ Pull others down.
  305.         zzel4 @ zzel5 @ + ( from )
  306.         zzel4 @   ( from to )
  307.         iv-many zzel4 @ - move: self
  308.     THEN
  309. ;M
  310.  
  311. :M REMOVE:  ( index  -- , remove and compress  )
  312.     1 chop: self
  313. ;M
  314.  
  315. :M FILL.DIM:    ( value d# -- , fill a dimension with a value )
  316.     iv-many ?dup
  317.     IF  0 DO
  318.         2dup i swap ed.to: self
  319.     LOOP 2drop
  320.     ELSE 2drop " FILL.DIM:" " Empty object!"
  321.         er_return ob.report.error
  322.     THEN
  323. ;M
  324.  
  325. :M PRINT.ELEMENT:  ( E# -- , Print an element )
  326.     dimension: self 0 DO
  327.         dup i ed.at: self 7 .r space
  328.     LOOP  drop
  329. ;M
  330.  
  331. :M PRINT.DIMENSION:  ( D# -- , PRINT A COLUMN )
  332.     cr iv-many 0 DO
  333.         i .   i over ed.at: self 8 .r  cr
  334.     LOOP drop
  335. ;M
  336.  
  337. :M PRINT:   ( -- , Print the elements of a shape )
  338.     cr name: self cr
  339.     ." ELMT\DIM " dimension: self 0 DO i  8 .r LOOP cr
  340.     iv-many dup
  341.     IF  0
  342.         DO   ( Use late binding for each element to allow mods)
  343.             i 6 .r  4 spaces
  344.             i self print.element: [] cr
  345.             ?pause
  346.         LOOP
  347.     ELSE drop ."   No Data!!" cr
  348.     THEN
  349. ;M
  350.  
  351. :M SET.MANY: ( many -- , force add of elements )
  352.     dup 0 iv-#elements within?
  353.     IF iv=> iv-many
  354.     ELSE . " SET.MANY:" " MANY outside range!"
  355.         er_fatal ob.report.error
  356.     THEN
  357. ;M
  358.  
  359. :M DUMP.ELEMENT: ( e# -- , print source for one element )
  360.     self print.element: []
  361.     ."  add: " name: self cr
  362. ;M
  363.  
  364. :M DUMP.SOURCE: ( -- , Print source code to recreate object. )
  365.     iv-pntr  ( check for data )
  366. \ Write NEW: for object.
  367.     IF  cr tab iv-#elements .  iv-dimension .
  368.         ."  new: " name: self cr
  369. \ Rcreate individual elements.
  370.         iv-many 0
  371.         DO  i self dump.element: []
  372.         LOOP cr
  373.     THEN
  374. ;M
  375.  
  376. :M FOREWARD: ( -- , advance read pointer by one )
  377.     1 iv+> iv-current
  378. ;M
  379. :M BACKWARD: ( -- , move read pointer back by one )
  380.     -1 iv+> iv-current
  381. ;M
  382.  
  383. :M GOTO: ( index -- , set data cursor)
  384.     iv=> iv-current
  385. ;M
  386.  
  387. :M WHERE: ( -- index , where is data cursor? )
  388.     iv-current
  389. ;M
  390.  
  391. :M EXTEND:  ( #elements -- , extend array area )
  392.     dup iv+> iv-#elements  ( new # elements )
  393.     iv-dimension *  ( #cells to add )
  394.     extend: super
  395. ;M
  396.  
  397. :M DO: ( function_cfa -- , pass each element to function )
  398.     iv-many 0
  399.     DO ( don't DUP>R before I for some Forths )
  400.         i over >r get: self r> execute
  401.     LOOP drop
  402. ;M
  403.  
  404. :M COPY: ( start target count target-object -- , copy data to it )
  405.     zzel4 ! ( target-object )
  406.     zzel3 ! ( count )
  407.     zzel2 ! ( target elmnt# )
  408.     zzel1 ! ( start elmnt# )
  409.     zzel1 @ 0 ed2i: self i2addr: self   ( source address )
  410.     zzel2 @ 0 zzel4 @ ed2i: [] dup>r    ( target unit # )
  411.     zzel4 @ i2addr: []                  ( target address )
  412.     zzel3 @ dimension: self * width: self *  ( #bytes to move )
  413.     zzel4 @ limit: [] ( max target unit # )
  414.     r> - zzel4 @ width: [] *
  415.     over <
  416.     IF . . .
  417.         " COPY: OB.ELMNTS" " Not enough room in target!"
  418.         er_fatal ob.report.error
  419.     ELSE
  420.         move
  421.     THEN
  422. ;M
  423.  
  424. :M }STUFF:  ( stuff... -- , stuff data and set many )
  425.     iv-pntr
  426.     IF  stuff.depth dimension: self / >r
  427.         <}stuff:>
  428.         r> set.many: self
  429.     ELSE cr ." Must be NEW:ed before }STUFF:" cr abort
  430.     THEN
  431. ;M
  432.  
  433. ;CLASS
  434.  
  435. METHOD DELETE:
  436. METHOD 0STUFF:
  437.  
  438. : 0DEPTH ( 0 ? ? ? -- N | -1, 'pick' position of first 0)
  439.     -1 ( default count )
  440.     depth 1
  441.     DO  i pick 0=
  442.         IF drop i 1- leave
  443.         THEN
  444.     LOOP
  445. ;
  446.  
  447. \ OB.LIST  ------------------------------------------------
  448. \ This class is currently implemented as a one dimensional
  449. \ OB.ELMNTS array.  Eventually it should be a linked list.
  450.  
  451. :CLASS OB.LIST  <SUPER OB.ELMNTS
  452.  
  453. :M ?NEW:  ( Max_elements -- addr | 0 )
  454.     1 ?NEW: SUPER   ( declare as one dimensional )
  455. ;M
  456.  
  457. :M NEW: ( max_elements -- , abort if error )
  458.     ?new: self <new:error>
  459. ;M
  460.  
  461. :M DUMP.SOURCE: ( -- , Print source code to recreate object. )
  462.     iv-pntr  ( check for data )
  463. \ Write NEW: for object.
  464.     IF  cr tab iv-#elements . ."  new: " name: self cr
  465. \ Rcreate individual elements.
  466.         many: self 0
  467.         DO  i self dump.element: []
  468.         LOOP cr
  469.     THEN
  470. ;M
  471.  
  472. :M DELETE: ( value -- , delete that value from list )
  473.     indexof: self
  474.     IF  remove: self
  475.     THEN
  476. ;M
  477.  
  478. \ Define as colon definition so it can be inherited
  479. \ by other classes not derived from LIST.
  480. : <0STUFF:> ( 0 m0 m1 ... mN -- , easy build of object list)
  481. \ Scan For 0 to count objects.
  482.     0DEPTH
  483.     dup 0>
  484.     IF  dup self new: []  ( 0 m0 m1 ... mN N -- )
  485.         dup self set.many: []
  486.         dup 0
  487.         DO 1- tuck self put: []
  488.         LOOP
  489.         2drop
  490.     ELSE
  491.         0< IF " 0STUFF:" " 0 required before object list!"
  492.             er_fatal ob.report.error
  493.         ELSE drop
  494.         THEN
  495.     THEN
  496. ;
  497.  
  498. :M 0STUFF: ( 0 m0 m1 ... mN -- , easy build of list )
  499.     <0stuff:>
  500. ;M
  501.  
  502. :M }STUFF:  ( stuff...  --- , load it into object )
  503.     stuff.depth >r
  504.         <}stuff:>
  505.     r> set.many: self
  506. ;M
  507.  
  508. ;CLASS
  509.  
  510.  
  511. METHOD FREEALL:
  512. METHOD ?INSTANTIATE:
  513. METHOD DEINSTANTIATE:
  514.  
  515. :CLASS OB.OBJLIST <SUPER OB.LIST
  516.  
  517. :M PRINT.ELEMENT: ( E# -- , PRINT OBJECT INFO )
  518.     get: self dup name: []  tab  .class: []
  519. ;M
  520.  
  521. :M DUMP.ELEMENT: ( E# -- , PRINT OBJECT INFO )
  522.     tab get: self name: []  ."  add: " name: self CR
  523. ;M
  524.  
  525. :M FREEALL: ( -- , Send free: message to all members. )
  526.     many: self dup 0 >
  527.     IF  0 DO
  528.         i get: self free: []
  529.     LOOP
  530.     ELSE drop
  531.     THEN
  532. ;M
  533.  
  534. :M DEINSTANTIATE:
  535.     many: self 0
  536.     DO
  537.         i get: self deinstantiate
  538.     LOOP
  539.     free: self
  540. ;M
  541.  
  542. :M ?INSTANTIATE: ( class_cfa many -- class_pfa | 0 )
  543.     >r >body r>  \ need pfa for instantiate
  544.     dup ?new: self \ 00001
  545.     IF
  546.         0
  547.         DO
  548.             dup <?instantiate> ?dup
  549.             IF
  550.                 add: self
  551.             ELSE
  552.                 self deinstantiate: []
  553.                 drop 0 LEAVE
  554.             THEN
  555.         LOOP
  556.     ELSE
  557.         2drop 0
  558.     THEN
  559. ;M
  560.  
  561. ;CLASS
  562.  
  563. \ For testing.
  564. if-testing @ .IF
  565. ob.elmnts ELM1
  566. : BUILD.ELM1
  567.     10 2 new: elm1
  568.     0  0 add: elm1
  569.     1 11 add: elm1
  570.     2 22 add: elm1
  571.     3 33 add: elm1
  572.     4 44 add: elm1
  573.     5 55 add: elm1
  574. ;
  575. : P1 print: elm1 ;
  576. OB.ELMNTS ELM2
  577. : P2 print: elm2 ;
  578.  
  579. .THEN
  580.